home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 44 / PC Actual CD 44.iso / Linux / Cygwin / full.exe / Disk1 / data1.cab / Tools / share / tk8.0 / safetk.tcl < prev    next >
Encoding:
Text File  |  1998-12-04  |  4.6 KB  |  149 lines
  1. # safetk.tcl --
  2. #
  3. # Support procs to use Tk in safe interpreters.
  4. #
  5. # SCCS: @(#) safetk.tcl 1.8 97/10/29 14:59:16
  6. #
  7. # Copyright (c) 1997 Sun Microsystems, Inc.
  8. #
  9. # See the file "license.terms" for information on usage and redistribution
  10. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11.  
  12. # see safetk.n for documentation
  13.  
  14. #
  15. #
  16. # Note: It is UNSAFE to let any untrusted code being executed
  17. #       between the creation of the interp and the actual loading
  18. #       of Tk in that interp.
  19. #       You should "loadTk $slave" right after safe::tkInterpCreate
  20. #       Otherwise, if you are using an application with Tk
  21. #       and don't want safe slaves to have access to Tk, potentially
  22. #       in a malevolent way, you should use 
  23. #            ::safe::interpCreate -nostatics -accesspath {directories...}
  24. #       where the directory list does NOT contain any Tk dynamically
  25. #       loadable library
  26. #
  27.  
  28. # We use opt (optional arguments parsing)
  29. package require opt 0.1;
  30.  
  31. namespace eval ::safe {
  32.  
  33.     # counter for safe toplevels
  34.     variable tkSafeId 0;
  35.  
  36.     #
  37.     # tkInterpInit : prepare the slave interpreter for tk loading
  38.     #
  39.     # returns the slave name (tkInterpInit does)
  40.     #
  41.     proc ::safe::tkInterpInit {slave} {
  42.     global env tk_library
  43.     if {[info exists env(DISPLAY)]} {
  44.         $slave eval [list set env(DISPLAY) $env(DISPLAY)];
  45.     }
  46.     # there seems to be an obscure case where the tk_library
  47.     # variable value is changed to point to a sym link destination
  48.     # dir instead of the sym link itself, and thus where the $tk_library
  49.     # would then not be anymore one of the auto_path dir, so we use
  50.     # the addToAccessPath which adds if it's not already in instead
  51.     # of the more conventional findInAccessPath
  52.     ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]]
  53.     return $slave;
  54.     }
  55.  
  56.  
  57. # tkInterpLoadTk : 
  58. # Do additional configuration as needed (calling tkInterpInit) 
  59. # and actually load Tk into the slave.
  60. # 
  61. # Either contained in the specified windowId (-use) or
  62. # creating a decorated toplevel for it.
  63.  
  64. # empty definition for auto_mkIndex
  65. proc ::safe::loadTk {} {}
  66.    
  67.     ::tcl::OptProc loadTk {
  68.     {slave -interp "name of the slave interpreter"}
  69.     {-use  -windowId {} "window Id to use (new toplevel otherwise)"}
  70.     } {
  71.     if {![::tcl::OptProcArgGiven "-use"]} {
  72.         # create a decorated toplevel
  73.         ::tcl::Lassign [tkTopLevel $slave] w use;
  74.         # set our delete hook (slave arg is added by interpDelete)
  75.         Set [DeleteHookName $slave] [list tkDelete {} $w];
  76.     }
  77.     tkInterpInit $slave;
  78.     ::interp eval $slave [list set argv [list "-use" $use]];
  79.     ::interp eval $slave [list set argc 2];
  80.     load {} Tk $slave
  81.     # Remove env(DISPLAY) if it's in there (if it has been set by
  82.     # tkInterpInit)
  83.     ::interp eval $slave {catch {unset env(DISPLAY)}}
  84.     return $slave
  85.     }
  86.  
  87.     proc ::safe::tkDelete {W window slave} {
  88.     # we are going to be called for each widget... skip untill it's
  89.     # top level
  90.     Log $slave "Called tkDelete $W $window" NOTICE;
  91.     if {[::interp exists $slave]} {
  92.         if {[catch {::safe::interpDelete $slave} msg]} {
  93.         Log $slave "Deletion error : $msg";
  94.         }
  95.     }
  96.     if {[winfo exists $window]} {
  97.         Log $slave "Destroy toplevel $window" NOTICE;
  98.         destroy $window;
  99.     }
  100.     }
  101.  
  102. proc ::safe::tkTopLevel {slave} {
  103.     variable tkSafeId;
  104.     incr tkSafeId;
  105.     set w ".safe$tkSafeId";
  106.     if {[catch {toplevel $w -class SafeTk} msg]} {
  107.     return -code error "Unable to create toplevel for\
  108.         safe slave \"$slave\" ($msg)";
  109.     }
  110.     Log $slave "New toplevel $w" NOTICE
  111.  
  112.     set msg "Untrusted Tcl applet ($slave)"
  113.     wm title $w $msg;
  114.  
  115.     # Control frame
  116.     set wc $w.fc
  117.     frame $wc -bg red -borderwidth 3 -relief ridge ;
  118.  
  119.     # We will destroy the interp when the window is destroyed
  120.     bindtags $wc [concat Safe$wc [bindtags $wc]]
  121.     bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave];
  122.  
  123.     label $wc.l -text $msg \
  124.         -padx 2 -pady 0 -anchor w;
  125.  
  126.     # We want the button to be the last visible item
  127.     # (so be packed first) and at the right and not resizing horizontally
  128.  
  129.     # frame the button so it does not expand horizontally
  130.     # but still have the default background instead of red one from the parent
  131.     frame  $wc.fb -bd 0 ;
  132.     button $wc.fb.b -text "Delete" \
  133.         -bd 1  -padx 2 -pady 0 -highlightthickness 0 \
  134.         -command [list ::safe::tkDelete $w $w $slave]
  135.     pack $wc.fb.b -side right -fill both ;
  136.     pack $wc.fb -side right -fill both -expand 1;
  137.     pack $wc.l -side left  -fill both -expand 1;
  138.     pack $wc -side bottom -fill x ;
  139.  
  140.     # Container frame
  141.     frame $w.c -container 1;
  142.     pack $w.c -fill both -expand 1;
  143.     
  144.     # return both the toplevel window name and the id to use for embedding
  145.     list $w [winfo id $w.c] ;
  146. }
  147.  
  148. }
  149.